(defpackage :linearize
  (:use :cl)
  (:export :main
           :start-linearize
           :demo
           :toggle-selection
           :linearize
           :hint
           :next-problem
           :stage-timeout
           ;; :navigate-back
           ;; :navigate-forward
           :step
           :undo))

(in-package :linearize)

;;(defvar *condition* :instruction)
(defvar *instruction-condition* :instruction)
(defvar *computation-condition* :both)
(defvar *show-representation* nil)
(defvar *always-hints* :regular-hints)
(defvar *control-panel-state* :no-control-panel)
(defvar *fmri-mode* :fmri)

(defclass pop-view (gwee:view)
  ()
  (:default-initargs
   :x 0 :y -29 :width 150 :height 30))

(defun expand (pop-view x y b)
  (declare (ignore x y b))
  (setf (gwee:view-y pop-view) 0
        (gwee:view-needs-update-p pop-view) t))

(defun retract (pop-view x y b)
  (declare (ignore x y b))
  (setf (gwee:view-y pop-view) -29
        (gwee:view-needs-update-p pop-view) t))

(defmethod shared-initialize :after ((obj pop-view) slots &key)
  (gwee:add-hook (gwee:enter-hook obj) 'expand)
  (gwee:add-hook (gwee:leave-hook obj) 'retract))

(defun event-callback (view event)
  (let ((c (gwee:component-for-view view)))
    (bt:event-callback c event)))

(defclass my-tree (smart-tree:smart-tree-view)
  ())

(defmethod gwee:draw-view :after ((view my-tree))
  (unless (d:event-callback view)
    (sdl:draw-box-* (gwee:view-to-top-x view 0)
                    (gwee:view-to-top-y view 0)
                    (gwee:view-width view)
                    (gwee:view-height view)
                    :color (gwee:gray 255)
                    :alpha 180)))

(defclass rep-view (gwee:view gwee:background-mixin)
  ())

(gwee:define-component linearize (pm:propagate-mixin ri:rollover-input-mixin rs:rollover-selection-mixin as:argument-submit-mixin ha:highlight-arrows-mixin chm:constants-and-unknown-help-mixin)
  ((instruction-condition :type (member :instruction :discovery) :initarg :instruction-condition :accessor instruction-condition)
   (ditch-hint :initarg :ditch-hint :initform nil :accessor ditch-hint)
   (ditch-navigation :initarg :ditch-navigation :initform t :accessor ditch-navigation)
   (no-linearize :initarg :no-linearize :initform nil :accessor no-linearize)
   (time-per-stage :initarg :time-per-stage :initform nil :accessor time-per-stage)
   (beads-overlay-on-mistake :initarg :beads-overlay-on-mistake :initform nil :accessor beads-overlay-on-mistake)
   (beads-overlay-on-hint :initarg :beads-overlay-on-hint :initform nil :accessor beads-overlay-on-hint)
   (hint-level :initform :last-state-only :accessor hint-level))
  (:views
   (divider gwee:divider
            :margin-bottom 0
            :direction :vertical
            :foreground (gwee:gray 150))
   (divider2 gwee:divider
             :margin-top 0
             :direction :vertical
             :foreground (gwee:gray 150))
   (p:diagram my-tree #|smart-tree:smart-tree-view|# :event-callback 'event-callback
                              :name :diagram-area)
   (bt:last-state smart-tree:smart-tree-view  #|tv:tree-view|# :gravity :left
                              :name :last-state-area :accessor bt:last-state)
   (bt:message gwee:column-layout :margin-left 5 :cell-gravity :top :gravity :top :height 75 :width :maximum :name :message-area)
   (hint gwee:button :width :maximum :data "Hint")
   (next-problem gwee:button :width :maximum :data "Next Problem")
   (first-mistake gwee:button :data "1st Mistake")
   (back gwee:button :data (string (code-char 8592)))
   (forward gwee:button :data (string (code-char 8594)))
   (bt:instruction-title-view gwee:text-area :data "Title"
                              :name :instruction-area
                              :width :maximum
                              :font (gwee:open-font "sans.ttf" 24))
   (bt:instruction-body-view gwee:text-area :data "instructions go here"
                              :name :instruction-area
                             :height :maximum
                             :width :maximum
                             :font (gwee:open-font "sans.ttf" 18))
   (rm:representation rep-view :x 0 :y 0 :width 0 :height 0
                      :border-color (gwee:gray 150)
                      :border-left nil
                      :border-right nil))
   (:layouts
    (default gwee:column-layout
        (top bottom))
    (top gwee:view
         (diagrams rm:representation))
    (diagrams gwee:row-layout
        (left divider right))
    (left gwee:column-layout
          (bt:last-state))
    (right gwee:column-layout
           (diagram-area))
    (empty gwee:view)
    (bottom gwee:row-layout
            (empty divider2 dashboard)
            :height :minimum)
    (dashboard gwee:column-layout
               (buttons bt:message)
               :height :minimum)
    (diagram-area gwee:view
                  (p:diagram))
    (buttons gwee:row-layout
             (;; back first-mistake forward
                   back forward hint next-problem)
             :margin-left 5
             :margin-right 5
             :margin-bottom 5
             :gravity :center
             :padding 5
             :height :minimum))
  (:default-initargs
      :navigate-skip-fills-p nil
   :last-state-mode :sticky-surgery
      :instruction-title "Solve the following problems"
    :instruction-body "If you get stuck, click the Hint button for a hint."
    :instruction-condition *instruction-condition*
    :computation-condition *computation-condition*
    :guidedp (eq *always-hints* :hints-always-on)
    ;; :show-rep-on-hint *show-representation*
    ;; :show-rep-on-mistake *show-representation*
    :green-overlay-on-mistake (not *show-representation*)
    :green-overlay-on-hint (not *show-representation*)
    :input-must-be-correct-p t))

(defmethod rm:highlight-rep-nodes-p ((state linearize))
  t)

(defmethod chm:instruction-condition ((state linearize))
  (instruction-condition state))

(defmethod exp:state-dump append (exp (state linearize))
  `(:instruction-condition ,(instruction-condition state)
    :ditch-hint ,(ditch-hint state)
    :ditch-navigation ,(ditch-navigation state)
    :no-linearize ,(no-linearize state)
    :time-per-stage ,(time-per-stage state)
    :beads-overlay-on-mistake (beads-overlay-on-mistake state)
    :beads-overlay-on-hint (beads-overlay-on-hint state)))

(defun evaluate-transformations (condition)
  (nd::nd-evaluate-transformations (ecase condition
                                     (:discovery :minimum)
                                     (:instruction :full))))

(defun invert-transformations (condition)
  (nd::nd-invert-transformations (ecase condition
                                   (:discovery :minimum)
                                   (:instruction :full))))

(defmethod pm:propagate-down-operation ((state linearize))
  (make-instance 'o:operation
                 :name :evaluate
                 :transformations (evaluate-transformations (instruction-condition state))))

(defmethod pm:propagate-up-operation ((state linearize))
  (make-instance 'o:operation
                 :name :invert
                 :transformations (invert-transformations (instruction-condition state))))

(defmethod pm:propagate-error-message ((trial linearize) node)
  (p:display-message trial :error "You cannot fill this tile yet."))

(defmethod bt:make-operations ((state linearize))
  (list (make-instance 'o:operation
                       :name :linearize
                       :hint (ecase (instruction-condition state)
                               (:instruction
                                "Now that all the boxes in the loop have been selected, click the Linearize button to convert this loop into a linear structure.")
                               (:discovery
                                "Click the Linearize Button."))
                       :transformations (list (make-instance 'lt:linearize-transformation
                                                             :condition (instruction-condition state))))))

(defmethod bt:make-operation-views ((state linearize))
  (unless (no-linearize state)
    (list (make-instance 'gwee:button
                         :data "Linearize"
                         :width :maximum
                         :click-callback (exp:dispatch-event-fn exp:*experiment* state
                                                                exp:click-event :source :linearize)))))

(defmethod p:show-hint-make-selection ((problem linearize) transformation selected-nodes selection)
  (let* ((arrows (set-exclusive-or selected-nodes selection))
         (wrong-boxes (set-difference selected-nodes selection)))
    (d:clear-arrows (d:root (p:diagram problem)))
    (dolist (i arrows)
      (setf (d:arrow i) (if (find i selection)
                            (gwee:color 0 255 0)
                            (gwee:color 255 0 0))))
    (cond
      ((> (length wrong-boxes) 1)
       (p:display-message problem :error "You have selected some incorrect boxes -- click the boxes pointed to by the red arrows to unselect them."))
      ((= (length wrong-boxes) 1)
       (p:display-message problem :error "You have selected an incorrect box -- click the box pointed to by the red arrow to unselect them."))
      (t
        (p:clear-message problem :error)))
    (when (eq (instruction-condition problem) :instruction)
      (p:display-message problem :hint "~a" (o:hint transformation)))))

(defmethod p:show-hint-fill-input ((problem linearize) tree)
  (multiple-value-bind (arg hint mistake) (guide::arg-fill-in-instructions tree)
    (if (typep hint 'lt::hint)
        (cond
          ((chm:overlay-on-hint problem)
           (if (or (eq (p:guidedp problem) t)
                   (eq (hint-level problem) :both))
               (chm::add-overlays-to-both-diagrams problem)
               (chm::add-overlay-to-last-state problem)))
          ((rm:show-rep-on-hint problem)
           (if (rm:representation-visible-p problem)
               (chm::add-overlay-to-current-state problem)
               (rm:make-representation problem)))
          (t (error "Dunno what to do")))
        (progn
          (d:point-to-nodes tree arg)
          (when (eq (instruction-condition problem) :instruction)
            (if (typep hint 'lt::hint)
                (p:display-message problem :hint (lt::hint-text hint))
                (p:display-message problem :hint hint)))
          (when mistake
            (p:display-message problem :error mistake))))))

(defmethod p:show-hint-already-wrong ((problem linearize))
  (p:display-message problem :hint "You've encountered an impossible situation! Ask the experimenter to restart the problem."))

(defmethod p:navigate-clean-up progn ((state linearize) how)
  (setf (hint-level state) :last-state-only)
  (beads:delete-bead-overlay (p:diagram state)))

(defmethod p:show-hint-choose-operation ((problem linearize) op)
  (when (eq (o:name op) :linearize)
    (beads:add-bead-overlay (p:diagram problem) (d:selected-nodes (d:root (p:diagram problem))) nil))
  (if (o:hint op)
      (p:display-message problem :hint "~a" (o:hint op))
      (p:display-message problem :hint "Click the ~a button." (substitute #\Space #\- (string-capitalize (o:name op))))))

(defmethod p:show-hint-finished ((problem linearize))
  (p:display-message problem :hint "You're finished! Click Next Problem."))

(defmethod p:show-hint-make-selection ((problem linearize) (transformation lt:linearize-transformation) selected-nodes selection)
  (let* ((wrong-boxes (set-difference selected-nodes selection))
         (base (lt:find-bottom-box (d:root (p:diagram problem)) selection))
         (rest (set-difference selection selected-nodes))
         (next-left (d:collect-on-tree (lambda (box) (find box rest))
                                       (d:box-left-arg base)
                                       :only-boxes t))
         (next-right (d:collect-on-tree (lambda (box) (find box rest))
                                        (d:box-right-arg base)
                                        :only-boxes t))
         (next (first (append next-left next-right))))
    (d:clear-arrows (d:root (p:diagram problem)))
    (if wrong-boxes
        (progn
          (beads:add-bead-overlay (p:diagram problem) selection next)
          (p:clear-message problem :hint)
          (dolist (i wrong-boxes)
            (setf (d:arrow i) (gwee:color 255 0 0)))
          (if (> (length wrong-boxes) 1)
              (p:display-message problem :error "You have selected some incorrect boxes -- click the boxes pointed to by the red arrows to unselect them."))
          (p:display-message problem :error "You have selected an incorrect box -- click the box pointed to by the red arrow to unselect them."))
        (progn
          (p:clear-message problem :error)
          (cond
            ((d:selected base)
             (beads:add-bead-overlay (p:diagram problem) selection next)
             (if (eq (instruction-condition problem) :instruction)
                 (p:display-message problem :hint "You need to select all the boxes on the loop. Select a box on the loop that has a single empty tile.")
                 (p:display-message problem :hint "Click a set of boxes in a pattern highlighted by a green line.")))
            (t
             (beads:add-bead-overlay (p:diagram problem) selection base)
             (if (eq (instruction-condition problem) :instruction)
                 (let ((base-text "You need to eliminate this loop. Start by clicking the box at the bottom of the loop."))
                   (if (and (tree:parent base)
                            (d:quantity (tree:parent base)))
                       (p:display-message problem :hint "You cannot propagate ~d up because the box above it has two little tiles resulting in two paths leading back to the unknown. ~a"
                                          (d:quantity (tree:parent base)) base-text)
                       (p:display-message problem :hint base-text)))
                 (p:display-message problem :hint "Click a set of boxes in a pattern highlighted by a green line."))))))))

(defmethod p:finish-select-mode progn ((problem linearize) last-eqn transformation)
  (beads:delete-bead-overlay (p:diagram problem))
  (reset-timer problem))

(defmethod p:finish-fill-mode progn ((problem linearize))
  (setf (hint-level problem) :last-state-only)
  (reset-timer problem))

(defmethod as:finish-collapsed-argument progn ((problem linearize) node)
  (setf (hint-level problem) :last-state-only)
  (reset-timer problem))

(defmethod p:wrong-tile-value progn ((problem linearize) node)
  (when (typep (p:transformation problem) 'lt:linearize-transformation)
    (cond
      ((chm:overlay-on-mistake problem)
       (let ((already (cuhelp-mixin::green-overlay-present-p problem)))
         (cuhelp-mixin::add-overlay-to-last-state problem node)
         (unless already
           (reset-timer problem))))
      ((rm:show-rep-on-mistake problem)
       (unless (rm:representation-visible-p problem)
         (rm:make-representation problem)
         (reset-timer problem))))))

(defun add-bead-overlay-for-linearize (problem)
  (let* ((selection (guide:get-selection (d:root (p:diagram problem))
                                         (list (find :linearize (p:operations problem) :key 'o:name))))
         (base (when selection
                 (lt:find-bottom-box (d:root (p:diagram problem)) selection))))
    (when selection
      (beads:add-bead-overlay (p:diagram problem) selection base)
      (d:update-diagram-view (p:diagram problem)))))

(defmethod p:do-operation :around ((problem linearize) (op-name (eql :linearize)))
  (let ((ret (call-next-method)))
    (when (and (not ret)
               (beads-overlay-on-mistake problem))
      (add-bead-overlay-for-linearize problem)
      (reset-timer problem))
    ret))

(defmethod p:toggle-selection :after ((problem linearize) node)
  (when (guide:operation-for-selection (d:root (p:diagram problem))
                                       (p:operations problem))
    (reset-timer problem)))

(defmethod p:clear-hints progn ((problem linearize))
  (beads:delete-bead-overlay (p:diagram problem)))

(defmethod exp:state-init (exp (state linearize))
  (labels ((wire (widget source)
             (setf (gwee:click-callback (slot-value state widget))
                   (exp:dispatch-event-fn exp state exp:click-event :source source))))

    (with-slots (hint back forward buttons) state
      (setf (gwee:view-subviews buttons) (append (butlast (gwee:view-subviews buttons))
                                                 (bt:make-operation-views state)
                                                 (last (gwee:view-subviews buttons))))
      (wire 'next-problem :next-problem)
      (wire 'first-mistake :first-mistake)
      (when (ditch-navigation state)
        (gwee:delete-view back)
        (gwee:delete-view forward))
      (wire 'back :back)
      (wire 'forward :forward)
      (if (or (ditch-hint state)
              (eq (p:guidedp state) t))
          (gwee:delete-view hint)
          (wire 'hint :hint))
      (when (typep (exp:parent-state exp) 'exp:subsequence)
        (let ((total (exp:subsequence-count (exp:parent-state exp)
                                            'linearize)))
          (when (> total 1)
            (p:display-message state :fyi "Problem ~d of ~d -- Reward: $~,2f"
                               (1+ (exp:subsequence-count (exp:parent-state exp)
                                                          'linearize
                                                          :end exp:*subsequence-nth*))
                               total
                               (/ (exp:reward exp) 100)))))
      ;;(p:display-message state :reward "Reward: $~,2f" (/ (exp:reward exp) 100))
      (make-instance 'pop-view
                     :parent state
                     :subviews (list
                                (make-instance 'gwee:text-area
                                               :background (gwee:gray 200)
                                               :width :maximum :height :maximum
                                               :vertical-justification :center
                                               :horizontal-justification :center
                                               :data (format nil "Reward: $~,2f" (/ (exp:reward exp) 100)))))
      (gwee:sync-views)
      (when (time-per-stage state)
        (exp:start-timer (time-per-stage state) :tag :stage-timeout)))))

(defmethod bt:convert-tree ((state linearize) tree)
  (append (dgraph:convert tree)
          (dgraph:attributes tree)
          (when (beads:find-overlay (p:diagram state))
            (list (beads:dump (beads:find-overlay (p:diagram state)))))
          ))

(defmethod exp:state-list-objects append (exp (state linearize))
  (list :buttons (mapcar 'gwee:view-data (gwee:view-subviews (slot-value state 'buttons)))))

(defmethod exp:state-list-actions append (exp (state linearize))
  (declare (ignore exp))
  (exp::default-list-actions state))

;; (defmethod exp:state-list-actions append (exp (state linearize))
;;   (cond
;;     ((bt:input state)
;;      `((bt:leave-action :node ,(d:id (kp:target (bt:input state))))
;;        (bt:fill-node-action :node ,(d:id (kp:target (bt:input state))) :input :string)
;;        ,@(unless (p:guidedp state) '(bt:help-action))))
;;     ((d:find-if-on-tree (constantly t) (d:root (p:diagram state)) :only-type 'd:input-argument)
;;      (let ((nodes (d:collect-on-tree (constantly t)
;;                                      (d:root (p:diagram state))
;;                                      :only-type 'd:input-argument)))
;;        (append
;;         (loop for i in nodes
;;            collect `(bt:enter-action :node ,(d:id i)))
;;         (unless (p:guidedp state) '(bt:help-action)))))
;;     (t
;;      (let ((empty-args (d:collect-on-tree (complement #'d:quantity)
;;                                           (d:root (p:diagram state))
;;                                           :only-type 'd:argument))
;;            (boxes (d:collect-on-tree (constantly t) (d:root (p:diagram state)) :only-type 'd:multi-argument-box)))
;;        `(,@(mapcar (lambda (a) `(bt:click-node-action :node ,(d:id a))) empty-args)
;;          ,@(mapcar (lambda (b) `(bt:click-node-action :node ,(d:id b))) boxes)
;;          ,@(unless (no-linearize state) `((bt:operation-action :name :linearize)))
;;          ,@(unless (p:guidedp state) '(bt:help-action))
;;          (exp:submit-action :name :next-problem))))))

(defun pick-next-input (tree)
  (let* ((inputs (sort (d:collect-on-tree (lambda (n)
                                            (and (string/= (u:string2 (d:quantity n))
                                                           (u:string2 (d:answer n)))))
                                          tree
                                          :only-type 'd:input-argument)
                       '< :key 'geom:y))
         (arrow (find-if 'd:arrow inputs)))
    (or arrow (first inputs))))

(defmethod bt:message-type-color ((state linearize) (type (eql :stage-advanced)))
  (gwee:color 255 0 0))

(defun reset-timer (state)
  (when (time-per-stage state)
    (exp:lg 'reset-timer)
    (gwee:cancel-all-timers)
    (exp:start-timer (time-per-stage state) :tag :stage-timeout)))

(defmethod rm:rep-collapsed-node progn ((state linearize))
  (reset-timer state))

(defmethod bt:hints-enabled progn ((state linearize))
  (reset-timer state)
  (when (eq (p:mode state) :select)
    (let ((green-present (cuhelp-mixin::green-overlay-present-p state)))
      (when green-present
        (cuhelp-mixin::clear-help state)
        (d:update-diagram-view (bt:last-state state))))))

(defun clear-messages-after-stage-advance (state)
  (with-slots (bt:message) state
    (when (find :stage-advanced (gwee:view-subviews bt:message) :key 'bt::message-type)
      (p:clear-message state :all))))

(defmethod p:toggle-selection :before ((state linearize) node)
  (clear-messages-after-stage-advance state)
  (cuhelp-mixin::clear-help state)
  (d:update-diagram-view (bt:last-state state)))

(defmethod bt:keypad-opened progn ((state linearize) target)
  (clear-messages-after-stage-advance state)
  (let* (;;(tree (d:root (p:diagram state)))
         ;;(input (pick-next-input tree))
         (green-present (cuhelp-mixin::green-overlay-present-p state)))
    (when (and (not (p:guidedp state))
               green-present)
      (cuhelp-mixin::clear-help state)
      (d:update-diagram-view (bt:last-state state)))))

(exp:define-action stage-timeout ((state linearize)
                                  (exp:timeout :tag :stage-timeout))
  (let* ((tree (d:root (p:diagram state)))
         (last-state-green-present (cuhelp-mixin::green-overlay-present-p
                                    state
                                    (d:root (bt:last-state state))))
         (current-state-green-present (cuhelp-mixin::green-overlay-present-p
                                       state
                                       (d:root (p:diagram state))))
         (rep-present (rm:representation-visible-p state))
         (input (pick-next-input tree))
         (selection (d:selected-nodes tree))
         selection-needed o)
    (exp:lg 'stage-timeout)
    (p:clear-message state :all)
    (if (find-if (lambda (v)
                   (typep v 'beads::beads-overlay))
                 (gwee:view-subviews (p:diagram state)))
        (multiple-value-setq (selection-needed o) (guide:get-selection tree (list (find :linearize (p:operations state)
                                                                                        :key 'o:name))))
        (multiple-value-setq (selection-needed o) (guide:get-selection tree (p:operations state))))
    (cond
      ;; clear the green arguments that were left after filling in a value
      ((and last-state-green-present
            (or (not input)
                (and (not (p:guidedp state))
                     (typep (d:hint input) 'lt::hint)
                     (eq (lt::hint-which (d:hint input)) :constant))))
       (cuhelp-mixin::clear-help state)
       (d:update-diagram-view (bt:last-state state)))
      ;; the rep should be filled in when it's present
      ((and rep-present
            (rm:representation-enabled-p state))
       (let* ((rep-view (first (gwee:view-subviews (rm:representation state))))
              (keypad (rm::find-rep-keypad state))
              (input (if keypad
                         (kp:target keypad)
                         (d:find-if-on-tree (constantly t)
                                            (d:root rep-view)
                                            :only-type 'd:input-argument
                                            :from-end t))))
         (setf (d:quantity input) (u:string2 (d:answer input)))
         (d:clear-highlights (d:root rep-view))
         (rm::delete-inputs state)
         (rm::collapse-node state rep-view input)
         (p:display-message state :stage-advanced "A tile in the equation has been filled in because you took too long!")))
      (input
       (cond
         ((chm:overlay-on-hint state)
          (cond
            ((and (typep (p:transformation state) 'lt:linearize-transformation)
                  (not last-state-green-present))
             (exp:lg 'stage-timeout-hint-level-last-state)
             (p:clear-message state :all)
             (p:show-hint state)
             (setf (p:guidedp state) (or (p:guidedp state) :stage))
             (bt:refresh-diagram state (p:diagram state)))
            ((and (typep (p:transformation state) 'lt:linearize-transformation)
                  last-state-green-present
                  (not current-state-green-present))
             (exp:lg 'stage-timeout-hint-level-both)
             (setf (hint-level state) :both)
             (p:clear-message state :all)
             (p:show-hint state)
             (setf (p:guidedp state) (or (p:guidedp state) :stage))
             (bt:refresh-diagram state (p:diagram state)))
            (t (when (bt:input state)
                 (kp:cancel-timer (bt:input state))
                 (bt:delete-input state))
               (let ((copy (tree:copy-node input nil)))
                 (d:clear-arrows (d:root (p:diagram state)))
                 (p::fill-input-box state input (u:string2 (d:answer input)))
                 (p:display-message state :stage-advanced "A tile has been filled in because you took too long!")
                 (when (and (not (p:guidedp state))
                            last-state-green-present)
                   (print `(doooooit))
                   (chm::add-last-state-overlay-helper (d:root (bt:last-state state)) copy :bothp (ecase (chm:computation-condition state)
                                                                                                    (:both t)
                                                                                                    (:split nil)))
                   (d:update-diagram-view (bt:last-state state)))
                 (bt:refresh-diagram state (p:diagram state))))))
         ((rm:show-rep-on-hint state)
          (if (and (typep (p:transformation state) 'lt:linearize-transformation)
                   (not rep-present))
              (progn
                (rm:make-representation state)
                (p:display-message state :stage-advanced "This equation popped up because you took too long!"))
              (progn
                (when (bt:input state)
                  (kp:cancel-timer (bt:input state))
                  (bt:delete-input state))
                (p::fill-input-box state input (u:string2 (d:answer input)))
                (p:display-message state :stage-advanced "A tile has been filled in because you took too long!")
                (bt:refresh-diagram state (p:diagram state)))))
         (t (error "input boxes but I don't know what to show for a hint!"))))
      ((and o
            (find (o:name o) '(:invert :evaluate)))
       (d:clear-selected tree)
       (setf (d:selected (first selection-needed)) t)
       (p:do-operation state (o:name o))
       (p:display-message state :stage-advanced "A tile has been clicked because you took too long!"))
      ((and o
            (null (set-exclusive-or selection selection-needed)))
       (p::do-operation state (o:name o))
       (p:display-message state :stage-advanced "Linearize has been clicked because you took too long!"))
      (selection-needed
       (if (find-if (lambda (v)
                      (typep v 'beads::beads-overlay))
                    (gwee:view-subviews (p:diagram state)))
           (progn
             (d:clear-selected tree)
             (d:clear-arrows tree)
             (dolist (i selection-needed) (setf (d:selected i) t))
             (bt:refresh-diagram state (p:diagram state))
             ;; ensure that the next hint is displayed, when needed
             (p:clear-message state :error)
             (p::update-guided-state state :stage)
             (when (p:guidedp state) (p:show-hint state))
             (p:display-message state :stage-advanced "The correct selection has been made because you took too long!"))
           (progn
             (add-bead-overlay-for-linearize state)
             (p:display-message state :stage-advanced "A hint has been turned on because you took too long!"))))
      (t
       (p:next-problem state)))
    (exp:lg 'stage-timeout-gobble-events)
    (gwee:clear-event-queue 0.25)
    (exp:lg 'stage-timeout-completed)
    (reset-timer state)))

(exp:define-event-match click-box ((trial linearize)
                                   (event e:click-event))
  (when (typep (e:target event) 'd:box)
    (d:id (e:target event))))

(exp:define-event-match click-selectable ((trial linearize)
                                          (event e:click-event))
  (cond
    ((typep (e:target event) 'd:box)
     (d:id (e:target event)))
    ((and (typep (e:target event) 'd:argument)
          (d:quantity (e:target event)))
     (d:id (tree:parent (e:target event))))
    (t nil)))

(exp:define-action toggle-selection ((trial linearize)
                                     (click-selectable :var id)
                                     (bt:select-mode))
  (let ((node (d:find-id-or-die (d:root (p:diagram trial)) id)))
    (p:toggle-selection trial node)
    (setf (gwee:view-needs-update-p (p:diagram trial)) t)))

(exp:define-action navigate-back ((state linearize)
                                  (exp:click :source :back))
  (p:navigate state :back (lambda () (bt:update-after-navigate state))))

(exp:define-action navigate-forward ((state linearize)
                                     (exp:click :source :forward))
  (p:navigate state :forward (lambda () (bt:update-after-navigate state))))

(exp:define-action linearize ((state linearize)
                              (exp:click :source :linearize)
                              (bt:select-mode))
  (p:do-operation state :linearize))

(exp:define-action operation ((state linearize)
                              (exp:click :source :linearize)
                              (bt:fill-mode))
  (exp:lg 'operation :name :linearize :successful nil)
  (p:display-message state :error "Operations cannot be performed while there are input boxes."))

(defun turn-on-both-hints (state)
  (setf (hint-level state) :both)
  (exp:lg 'hint :already-guided (p:guidedp state) :hint-level :both)
  (setf (p:guidedp state) (or (p:guidedp state) :stage))
  (incf (p:num-hints state))
  (p:clear-message state :all)
  (p:show-hint state)
  (bt:refresh-diagram state (p:diagram state)))

(exp:define-action hint ((state linearize)
                         (exp:click :source :hint))
  (if (and (rm:show-rep-on-hint state)
           (rm:representation-enabled-p state))
      (rm:turn-on-arrows state)
      (if (or (and (p:guidedp state)
                   (eq (hint-level state) :last-state-only))
              (and (not (p:guidedp state))
                   (chm::green-overlay-present-p state (d:root (bt:last-state state)))
                   (not (chm::green-overlay-present-p state (d:root (p:diagram state))))))
          (turn-on-both-hints state)
          (bt:turn-on-hints-for-stage state))))

(exp:define-action next-problem ((state linearize)
                                 (exp:click :source :next-problem))
  (p:next-problem state))

(exp:define-action step ((state linearize)
                         (exp:click :source :step))
  (bt:wizard-step state))

(exp:define-action undo ((state linearize)
                         (exp:click :source :undo))
  (bt:wizard-undo state))

(defclass demo (demo:demo)
  ((problem :initarg :problem :accessor problem)
   (instruction-condition :initarg :instruction-condition :accessor instruction-condition)
   (computation-condition :initarg :computation-condition :accessor computation-condition))
  (:default-initargs
   :instruction-condition *instruction-condition*
   :computation-condition *computation-condition*))

(defmethod exp:state-dump append (exp (state demo))
  `(:problem ,(problem state)))

(defun generate-demo (problem ic cc)
  (let ((hint-level (ecase ic
                      (:instruction :full)
                      ((:discovery :expression) :minimum))))
    (ld:generate problem ic cc
                 (make-instance 'o:operation :name :evaluate
                                :transformations (nd::nd-evaluate-transformations hint-level))
                 (make-instance 'o:operation :name :evaluate
                                :transformations (nd::nd-invert-transformations hint-level))
                 (make-instance 'o:operation :name :linerize
                                :transformations (list (make-instance 'lt:linearize-transformation
                                                                      :condition (ecase ic
                                                                                   (:instruction :instruction)
                                                                                   ((:discovery :expression) :discovery))))))))

(defmethod exp:state-init :before (exp (demo demo))
  (setf (demo:states demo)
        (generate-demo (problem demo) (instruction-condition demo) (computation-condition demo))))

(defun propagate-demo ()
  `(demo :problem "3*x-9,x=4"))

(defun easier-linearize-demo ()
  `(demo :problem "(B-Cr)+F=29,F=B*Cr,B=5"))

(defun harder-linearize-demo ()
  `(demo :problem "(A+B)-F=23,A=B*Cr,F=Cr*2,B=2+H,H=7"))

(defun multiple-linearizes-demo ()
  `(demo :problem "(1+(C+F))+5=15,F=C-((6+C)-(C+11)),C=(Sr+2)-5"))

(defclass maybe-panel (panel:control-panel)
  ((show-panel :initarg :show-panel :accessor show-panel))
  (:default-initargs
   :show-panel (eq *control-panel-state* :show-control-panel)))
  
(defmethod exp:state-init :around (exp (state maybe-panel))
  (if (show-panel state)
      (call-next-method)
      (exp:lg 'start :index (exp:subsequence-index state))))

(defmethod exp:state-clean-up :around (exp (state maybe-panel))
  (if (show-panel state)
      (call-next-method)
      (exp:lg 'end)))

(defmethod exp:state-dump append (exp (state maybe-panel))
  `(:show-panel ,(show-panel state)))
  
(defun set-options (options)
  (labels ((get (n)
             (exp:option-value (find n options :key 'exp:option-name))))
    (setf *always-hints* (get :always-hints)
          ;;*condition* (get :condition)
          *instruction-condition* (get :instruction-condition)
          *computation-condition* (ecase (get :computation-condition)
                                    (:split-computations :split)
                                    (:both-computations :both))
          *fmri-mode* (get :fmri-mode)                                     
          ;; *show-representation* (ecase *condition*
          ;;                         ((:instruction :discovery) nil)
          ;;                         (:expression t))
          *control-panel-state* (get :control-panel)
          ;; ri:*default-keypad-timeout* (ecase (get :keypad-delay)
          ;;                               (:normal-keypad-delay 0.25)
          ;;                               (:no-keypad-delay 0))
          ;; chm::*help-mode* (ecase (get :help-mode)
          ;;                    (:green-boxes chm::*green-box-help*)
          ;;                    (:inputs chm::*unknown-help-mode*)
          ;;                    (:expressions chm::*expression-help-mode*)
          ;;                    (:triangles chm::*triangle-help-mode*))
          )))

(defun base-interlace-nback (problems &key randomize nback crosshair)
  "nback crosshair p crosshair nback crosshair p crosshair nback"
  (when randomize
    (setf problems (u:randomize-list problems)))
  (cons
   nback
   (loop for rest on problems
      for p = (first rest)
      append `(,crosshair
               ,p
               ,crosshair
               ,nback))))

(defun interlace-nback (problems)
  (base-interlace-nback problems :randomize nil
                        :nback '(exp:nback)
                        :crosshair '(exp:fmri-crosshair :duration 2)))

(defun interlace-nonfmri-nback (problems)
  (base-interlace-nback problems :randomize nil
                        :nback '(exp:nback)
                        :crosshair '(exp:crosshair :duration 2)))

(defun get-problems-from-sets (n-each sets)
  (loop for i below (length sets)
     append (u:popn n-each (elt sets i))))

(defun scanner-session (num-blocks n-each &rest problem-sets)
  (let ((sync (ecase *fmri-mode*
                (:fmri 'exp:synchronize-pulse)
                (:behavioral 'exp:dummy-synchronize-pulse)))
        (crosshair (ecase *fmri-mode*
                     (:fmri 'exp:fmri-crosshair)
                     (:behavioral 'exp:crosshair)))
        (interlace (ecase *fmri-mode*
                     (:fmri #'interlace-nback)
                     (:behavioral #'interlace-nonfmri-nback))))
    (assert (every (lambda (set)
                     (and (zerop (mod (length set) n-each))
                          (= (/ (length set) n-each) num-blocks)))
                   problem-sets))
    (loop
       with pool = problem-sets
       for b from 1 to num-blocks
       for problems = (get-problems-from-sets n-each pool)
       append `((exp:message :text (,(format nil "Block ~d of ~d" b num-blocks) "Wait for Experimenter"))
                (,sync)
                (,crosshair :duration 8)
                (exp:subsequence :children ,(funcall interlace problems))
                (,crosshair :duration 8)))))

(defun read-problems (file initargs)
  (with-open-file (s (gwee:top-level-path (format nil "problems/~a.txt" file)))
    (loop for p = (read-line s nil s)
       until (eq p s)
       collect `(linearize :equation ,p ,@initargs))))

(defun stage-timeout ()
  (let ((state (exp:current-state exp:*experiment*)))
    (when (typep state 'linearize)
      (gwee:cancel-all-timers)
      (exp:state-dispatch-event exp:*experiment* state
                                (make-instance 'exp:timer-event :tag :stage-timeout)))))

(defun day-1-propagate ()
  (let* ((guided '(linearize :equation "10-4*X,X=2" :guidedp t :no-linearize t))
         (initargs '(:no-linearize t))
         (problems (interlace-nonfmri-nback (read-problems "propagate" initargs))))
    `(maybe-panel
      :children ((exp:click-instructions
                  :text ("Welcome!"
                         ""
                         "Your task is to find the values for the empty tiles in each"
                         "of the puzzles."
                         ""
                         "First, you will step through a demo puzzle to see how one is"
                         "solved. Then you will solve a puzzle while being guided through"
                         "each step. Finally, you will solve the remaining puzzles unguided"
                         "unless you ask for help.")
                  :onward-text "Click to Continue")
                 (exp:click-instructions
                  :text ("How to Earn Money"
                         ""
                         "On each puzzle you can win reward money for solving it correctly."
                         "You'll win more or less depending on the difficulty of the puzzle."
                         ""
                         "However, when you click the hint button 4 cents are deducted from"
                         "the reward. So only ask for one when you really need it!"
                         ""
                         "The reward will never drop below $0.")
                  :onward-text "Click to Continue")
                 (exp:click-message :text ("Demo Puzzle"
                                           ""
                                           "Click the arrow buttons to walk through the puzzle."
                                           "Each step is important, so watch closely!")
                                    :onward-text "Click to Start the Demo")
                 ,(propagate-demo)
                 (exp:click-message :text ("Guided Puzzle"
                                           ""
                                           "Now it's your turn. Follow the instructions below the"
                                           "puzzle diagram to solve it. Use the arrow buttons to"
                                           "review your work.")
                                    :onward-text "Click to Begin")
                 ,guided
                 (exp:click-message :text ("It's Time to Make Some Money"
                                           ""
                                           "Solve the following puzzles. If you need some help, click"
                                           "the hint button. But remember: it'll cost you 4 cents so only"
                                           "use it when you really need it!")
                                    :onward-text "Click to Continue")
                 (exp:click-message :text ("Match Task"
                                           ""
                                           "Between each puzzle you will have an extra task."
                                           "Any time a letter appears twice in a row, click"
                                           "the Match! button.")
                                    :onward-text "Click to Begin")
                 (exp:crosshair :duration 2)
                 (exp:subsequence :children ,problems)
                 (exp:crosshair :duration 2)
                 (exp:reward)))))

(defun day-1-intro ()
  `(maybe-panel
    :extra (stage-timeout)
    :children
    ((exp:click-instructions
      :text ("Welcome!"
             ""
             "Your task is to find the value of the red tile in each of"
             "the puzzles."
             ""
             "First, you will step through a demo puzzle to see how one is"
             "solved. Then you will solve a puzzle while being guided through"
             "each step. Finally, you will solve the remaining puzzles unguided"
             "unless you ask for help."
             ""
             "A special action, called Linearize, is available to simplify parts"
             "of the puzzle as you work to find the red tile's value.")
      :onward-text "Click to Continue")
     (exp:click-instructions
      :text ("How to Earn Money"
             ""
             "On each puzzle you can win reward money for solving it correctly."
             "You'll win more or less depending on the difficulty of the puzzle."
             "However, some things reduce size of the reward."
             ""
             "When you click Linearize with the wrong boxes selected 2 cents"
             "are deducted."
             ""
             "When you ask for a hint 4 cents are deducted."
             ""
             "The reward will never drop below $0.")
      :onward-text "Click to Continue")
     (exp:click-message :text ("Demo Puzzle"
                               ""
                               "Click the arrow buttons to walk through the puzzle."
                               "Each step is important, so watch closely!")
                        :onward-text "Click to Start the Demo")
     ,(easier-linearize-demo)
     (exp:click-message :text ("Guided Puzzle"
                               ""
                               "Now it's your turn. Follow the instructions below the"
                               "puzzle diagram to solve it.")
                        :onward-text "Click to Begin")
     (linearize :equation "5-Xr-Xr-8=-17" :guidedp t :time-per-stage 60)
     (exp:end))))

(defun day-1-scanner ()
  `(maybe-panel
    :extra (stage-timeout)
    :children
    ((exp:click-message :text ("5 Blocks"
                               ""
                               "The remaining puzzles are divided into 5 blocks. Each"
                               "block has 8 puzzles. You will have 1 minute to complete"
                               "each step of the puzzle. After 1 minute the program will"
                               "move you forward automatically."
                               ""
                               "Between puzzles you will have an extra task."
                               "Any time a letter appears twice in a row, click"
                               "the Match! button.")
                        :onward-text "Click to Begin")
     ,@(scanner-session 5 8 (read-problems "day1-scanner" '(:time-per-stage 60 :beads-overlay-on-mistake t)))
     (exp:reward))))

(defun day-2-warmup ()
  `(maybe-panel
    :children ((exp:click-instructions :text ("Selecting Boxes"
                                              ""
                                              "Your task in the following puzzles is to select the boxes"
                                              "that can be linearized. Once selected, click the 'Done' button."
                                              "The program will tell you if you got it right and show the"
                                              "correct selection."
                                              ""
                                              "On each puzzle you can win reward money for solving"
                                              "it correctly.")
                                       :onward-text "Click to Begin")
               ,@(selection-task:read-problems "2a")
               (exp:click-instructions :text ("Finding the Values"
                                              ""
                                              "In the following puzzles the left area shows a diagram"
                                              "with a selection, while the right area shows the diagram after"
                                              "the selection has been linearized. Your task is to fill the"
                                              "blue tiles with the correct values."
                                              "The program will tell you if you got it right and show the"
                                              "correct values for blue tiles."
                                              ""
                                              "On each puzzle you can win reward money for solving"
                                              "it correctly.")
                                       :onward-text "Click to Begin")
               ,@(fill-task::read-problems "2b" "transfer")
               (exp:reward))))

(defun day-2-selection ()
  `(maybe-panel
    :children ((exp:click-instructions
                :text ("Selecting Boxes"
                       ""
                       "Select the boxes that can be linearized."
                       ""
                       "There are 24 puzzles to solve."
                       ""
                       "You have 1 minute to solve each puzzle."
                       ""
                       "On each puzzle you can win reward money for solving"
                       "it correctly.")
                :onward-text "Click to Begin")
               ,@(selection-task:read-problems "2c")
               (exp:reward))))

(defun day-2-execution ()
  `(maybe-panel
    :children ((exp:click-message
                :text ("Finding the Values"
                       ""
                       "Fill the blue tiles with the correct values."
                       ""
                       "There are 8 blocks with 8 puzzles each."
                       ""
                       "You have 1 minute to solve each puzzle."
                       ""
                       "On each puzzle you can win reward money for solving"
                       "it correctly."
                       ""
                       "Between each puzzle you will have an extra task."
                       "Any time a letter appears twice in a row, click"
                       "the Match! button.")
                :onward-text "Click to Begin")
               ,@(scanner-session 8 8 (fill-task::read-problems "2d" "transfer"))
               (exp:reward))))

(defun main ()
  (let* ((rs (make-random-state))
         messages
         (sessions (mapcar (lambda (sym)
                             (list (u:symbol-capitalize sym) sym))
                           '(day-1-propagate day-1-intro day-1-scanner day-2-warmup day-2-selection day-2-execution))))
    (setf model-server:*package-list*
          (mapcar 'find-package '(:experiment :basic-trial :linearize :diagram :demo :propagate-mixin :rollover-input :selection-task :fill-task :highlight-arrows :rollover-selection)))
    (setf gwee::*resource-base-pathname* (make-pathname :name nil
                                                        :type nil
                                                        :defaults (or #.*compile-file-pathname* *load-pathname*)))
    (exp:run-experiment
     sessions
     :startup-message (when messages (format nil "~{~a~^~%~}" messages))
     :options (list (make-instance 'exp:option
                                   :name :instruction-condition
                                   :values '(:instruction :discovery)
                                   :initial-value *instruction-condition*)
                    (make-instance 'exp:option
                                   :name :computation-condition
                                   :values '(:split-computations :both-computations)
                                   :initial-value (ecase *computation-condition*
                                                    (:split :split-computations)
                                                    (:both :both-computations)))
                    (make-instance 'exp:option
                                   :name :control-panel
                                   :values '(:no-control-panel :show-control-panel)
                                   :initial-value *control-panel-state*)
                    (make-instance 'exp:option
                                   :name :fmri-mode
                                   :values '(:behavioral :fmri)
                                   :initial-value *fmri-mode*)
                    ;; (make-instance 'exp:option
                    ;;                :name :keypad-delay
                    ;;                :values '(:normal-keypad-delay :no-keypad-delay)
                    ;;                :initial-value :normal-keypad-delay)
                    (make-instance 'exp:option
                                   :name :always-hints
                                   :values '(:hints-always-on :regular-hints)
                                   :initial-value *always-hints*))
     :option-formatter 'u:symbol-capitalize
     :options-callback 'set-options
     ;; :width 1024
     ;; :height 768
     :title "Linearize"
     :resizable t
     :width 1280
     :height 800
     :version (boxes.util:version)
     :model-server nil
     :log `(:random-state ,rs))))

(defun start-linearize ()
  (gwee:process-run-function "linearize" #'main))

(defun problems ()
  (exp:run-experiment
   (sf:read-all-sessions 'linearize :containers '((panel:control-panel)))))

(defun randomize-fill-files (blocks &rest files)
  (labels ((process-lines (lines)
             (loop for rest = lines then (cddr rest)
                while rest
                for p1 = (first rest)
                for p2 = (or (second rest) "(b1)")
                collect (list p1 p2)))
           (load-file (f)
             (with-open-file (s (gwee:top-level-path (format nil "transfer/~a.txt" f)))
               (process-lines
                (loop for line = (read-line s nil s)
                   until (eq line s)
                   do (setf line (string-trim " 	" line))
                   when (plusp (length line))
                   collect line)))))
    (let ((sets (loop for f in files
                   collect (u:randomize-list (load-file f)))))
      (with-open-file (s (gwee:top-level-path "transfer/out.txt")
                         :direction :output
                         :if-exists :supersede
                         :if-does-not-exist :create)
        (mapcar (lambda (line)
                  (write-line (first line) s)
                  (write-line (second line) s))
                (loop for i below blocks
                   append (u:randomize-list (get-problems-from-sets 1 sets))))))))

(defun randomize-select-files (blocks &rest files)
  (let ((sets (loop for f in files
                 for lines = (with-open-file (s (gwee:top-level-path (format nil "transfer/~a.txt" f)))
                               (loop for line = (read-line s nil s)
                                  until (eq line s)
                                  do (setf line (string-trim " 	" line))
                                  when (plusp (length line))
                                  collect line))
                 collect (u:randomize-list lines))))
    (with-open-file (s (gwee:top-level-path "transfer/out.txt")
                       :direction :output
                       :if-exists :supersede
                       :if-does-not-exist :create)
      (mapcar (u:curry write-line (line) s)
              (loop for i below blocks
                 append (u:randomize-list (get-problems-from-sets 1 sets)))))))
